home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / parser / decl-parser.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  5.5 KB  |  185 lines  |  [TEXT/CCL2]
  1. ;;; File: decl-parser           Author: John
  2.  
  3. (define (parse-decl)
  4.   (let ((decl-type (find-decl-type)))
  5.     (cond ((eq? decl-type 'signdecl)
  6.        (parse-signdecl))
  7.       ((eq? decl-type 'pat-or-op)
  8.        (parse-pat-or-op))
  9.       ((eq? decl-type 'fundef)
  10.        (parse-fundef))
  11.       ((eq? decl-type 'plus-def)
  12.        (parse-plus-def))
  13.       ((eq? decl-type 'annotation)
  14.        (make annotation-decls (annotations (parse-annotations 'decl)))))))
  15.  
  16. ;;; This looks at the first tokens in a definition to determine it's type.
  17. ;;;   var (:: | ,)      - signdecl
  18. ;;;   var apat-start    - function definition
  19. ;;;   (var | _) +       - definition of infix +
  20. ;;;   anything alse     - pattern binding or infix definition
  21.  
  22. (define (find-decl-type)
  23.   (let* ((saved-excursion (save-scanner-state))
  24.      (decl-type
  25.       (token-case
  26.        (var (scan-var)
  27.         (token-case
  28.          ((\, \:\:) 'signdecl)
  29.          (apat-start 'fundef)
  30.          (+ 'plus-def)
  31.          (else 'pat-or-op)))
  32.        (_ (token-case
  33.            (+ 'plus-def)
  34.            (else 'pat-or-op)))
  35.        (begin-annotation 'annotation)
  36.        (else 'pat-or-op))))
  37.     (restore-excursion saved-excursion)
  38.     decl-type))
  39.  
  40. ;;; These are the different flavors of decl parsers
  41.  
  42. (define (parse-signdecl)
  43.  (save-parser-context
  44.   (trace-parser signdecl
  45.     (let ((vars (parse-signdecl-vars)))
  46.       (require-token \:\:
  47.              (signal-missing-token "`::'" "signature declaration"))
  48.       (let ((signature (parse-signature)))
  49.     (make signdecl (vars vars) (signature signature)))))))
  50.  
  51. (define (parse-signdecl-vars)
  52.   (token-case
  53.    (var (let ((var (var->ast)))
  54.       (token-case (\, (cons var (parse-signdecl-vars)))
  55.               (else (list var)))))
  56.    (else (signal-missing-token "<var>" "signature declaration"))))
  57.  
  58. (define (parse-pat-or-op)
  59.   (trace-parser patdef
  60.     (let* ((line-number (capture-current-line))
  61.        (pat (parse-pat)))
  62.       (token-case
  63.        (varop (parse-infix-def pat line-number))
  64.        (else (add-rhs pat '() '#f line-number))))))
  65.  
  66. (define (parse-infix-def pat1 line-number)
  67.   (let* ((op (make var-pat (var (varop->ast))))
  68.      (pat2 (parse-pat)))
  69.     (add-rhs op (list pat1 pat2) '#t line-number)))
  70.  
  71. (define (parse-fundef)
  72.  (trace-parser fundef
  73.   (let* ((start-line (capture-current-line))
  74.      (fn (parse-apat))  ; must be a single variable
  75.      (args (parse-apat-list)))
  76.     (add-rhs fn args '#f start-line))))
  77.  
  78. (define (parse-plus-def)
  79.   (trace-parser plus-def
  80.     (let* ((start-line (capture-current-line))
  81.        (var (parse-apat)))
  82.       (parse-infix-def var start-line))))
  83.  
  84. (define (add-rhs pat args infix? start-line)
  85.   (let* ((rhs (parse-rhs))
  86.      (decls (parse-where-decls))
  87.      (single (make single-fun-def
  88.                (args args)
  89.                (rhs-list rhs)
  90.                (where-decls decls)
  91.                (infix? infix?)))
  92.      (valdef (make valdef (lhs pat) (definitions (list single)))))
  93.     (setf (ast-node-line-number single) start-line)
  94.     (setf (ast-node-line-number valdef) start-line)
  95.     valdef))
  96.  
  97. (define (parse-rhs)
  98.   (token-case
  99.    (= (let ((rhs (parse-exp)))
  100.     (list (make guarded-rhs (guard (make omitted-guard)) (rhs rhs)))))
  101.    (\| (parse-guarded-rhs))
  102.    (else
  103.     (signal-missing-token "`=' or `|'" "rhs of valdef"))))
  104.  
  105. (define (parse-guarded-rhs) ; assume just past |
  106.  (trace-parser guard
  107.   (let ((guard (parse-exp-i)))  ; 1.2 change
  108.     (require-token = (signal-missing-token "`='" "guarded rhs"))
  109.     (let* ((exp (parse-exp))
  110.        (res (make guarded-rhs (guard guard) (rhs exp))))
  111.       (token-case
  112.        (\| (cons res (parse-guarded-rhs)))
  113.        (else (list res)))))))
  114.  
  115. (define (parse-where-decls)
  116.   (token-case
  117.    (|where|
  118.     (parse-decl-list))
  119.    (else '())))
  120.  
  121. (define (parse-decl-list)
  122.   (start-layout (function parse-decl-list-1)))
  123.  
  124. (define (parse-decl-list-1 in-layout?)
  125.   (token-case
  126.    ((apat-start begin-annotation)
  127.     (let ((decl (parse-decl)))
  128.       (token-case
  129.        (\; (decl-cons decl (parse-decl-list-1 in-layout?)))
  130.        (else (close-layout in-layout?)
  131.          (list decl)))))
  132.    (else
  133.     (close-layout in-layout?)
  134.     '())))
  135.  
  136. ;;; This adds a new decl to a decl list.  Successive decls for the same fn
  137. ;;; are combined.
  138.  
  139. (define (decl-cons decl decl-list)
  140.   (cond ((null? decl-list)
  141.      (list decl))
  142.     (else (nconc (combine-decls decl (car decl-list)) (cdr decl-list)))))
  143.  
  144. (define (decl-push decl decl-stack)
  145.   (cond ((null? decl-stack)
  146.      (list decl))
  147.     (else (nconc (nreverse (combine-decls (car decl-stack) decl))
  148.              (cdr decl-stack)))))
  149.  
  150. (define (combine-decls decl1 decl2)
  151.   (if (and (is-type? 'valdef decl1)
  152.        (is-type? 'valdef decl2)
  153.        (same-decl-var? (valdef-lhs decl1) (valdef-lhs decl2)))
  154.       (if (eqv? (length (single-fun-def-args (car (valdef-definitions decl1))))
  155.         (length (single-fun-def-args (car (valdef-definitions decl2)))))
  156.       (begin
  157.         (setf (valdef-definitions decl1)
  158.           (nconc (valdef-definitions decl1)
  159.              (valdef-definitions decl2)))
  160.         (list decl1))
  161.       (signal-multiple-definitions-arity-mismatch (valdef-lhs decl1)))
  162.       (list decl1 decl2)))
  163.  
  164. (define (same-decl-var? pat1 pat2)
  165.   (and (is-type? 'var-pat pat1)
  166.        (is-type? 'var-pat pat2)
  167.        (let ((n1 (var-ref-name (var-pat-var pat1)))
  168.          (n2 (var-ref-name (var-pat-var pat2))))
  169.      (if (eq? n1 n2)
  170.          '#t
  171.          (begin
  172.            (let ((s1 (string-upcase (symbol->string n1)))
  173.              (s2 (string-upcase (symbol->string n2))))
  174.          (when (string=? s1 s2)
  175.                (haskell-warning 'possible-misspelled-function
  176.   "Definitions of ~A and ~A together - maybe one is misspelled" n1 n2))
  177.          '#f))))))
  178.  
  179. (define (signal-multiple-definitions-arity-mismatch pat)
  180.   (parser-error 'multiple-definitions-arity-mismatch
  181.         "Definition of ~a does not match arity of previous definition."
  182.         pat))
  183.            
  184.      
  185.